perm filename COMP.LSP[C,JRA] blob
sn#012871 filedate 1972-11-17 generic text, type T, neo UTF8
00100
00200
00300 (DEFPROP MACFNS
00400 (NIL MACFNS
00500 INCR
00600 MCONS
00700 DFUNC
00800 FLUSHDEF
00900 GETPROP
01000 IFIF
01100 MAPDEF
01200 OUTINST
01300 OUTPSOP
01400 OUTTAG
01500 PDLDEPTH
01600 Q
01700 TAGP
01800 USERWARN
01900 FIRSTPROP
02000 LASTPROP
02100 NEXTPROP
02200 PROPNAM
02300 PROPVAL
02400 PASS1
02500 MACLAMBDA
02600 P1SETQ
02700 MACSETQ
02800 P1PROG
02900 P2ARG
03000 P1LAM)
03100 VALUE)
03200
03300 (DEFPROP INCR
03400 (LAMBDA (L) (LIST (Q SETQ) (CADR L) (LIST (Q ADD1) (CADR L))))
03500 MACRO)
03600
03700 (DEFPROP MCONS
03800 (LAMBDA (L) (COND ((NULL (CDDR L)) (CADR L)) (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
03900 MACRO)
04000
04100 (DEFPROP DFUNC
04200 (LAMBDA (L) (LIST (Q DEFPROP) (CAADR L) (MCONS (Q LAMBDA) (CDADR L) (CDDR L)) (Q EXPR)))
04300 MACRO)
04400
04500 (DEFPROP FLUSHDEF
04600 (LAMBDA (L) (CONS (Q FLUSHEXPR) (CDR L)))
04700 MACRO)
04800
04900 (DEFPROP GETPROP
05000 (LAMBDA (L) (CONS (Q GET) (CDR L)))
05100 MACRO)
05200
05300 (DEFPROP IFIF
05400 (LAMBDA (L) (LIST (Q COND) (CDR L) (LIST T (CONS (Q NOT) (CDDR L)))))
05500 MACRO)
05600
05700 (DEFPROP MAPDEF
05800 (LAMBDA(L)
05900 (LIST (Q MAPCAR)
06000 (SUBST (CADR L) (Q IND) (Q (FUNCTION (LAMBDA (PAIR) (PUTPROP (CAR PAIR) (CADR PAIR) (QUOTE IND))))))
06100 (LIST (Q QUOTE) (CDDR L))))
06200 MACRO)
06300
06400 (DEFPROP OUTINST
06500 (LAMBDA (INST) (CONS (Q OUTSTAT) (CDR INST)))
06600 MACRO)
06700
06800 (DEFPROP OUTPSOP
06900 (LAMBDA (PSOP) (CONS (Q OUTSTAT) (CDR PSOP)))
07000 MACRO)
07100
07200 (DEFPROP OUTTAG
07300 (LAMBDA (TAG) (CONS (Q OUTSTAT) (CDR TAG)))
07400 MACRO)
07500
07600 (DEFPROP PDLDEPTH
07700 (LAMBDA (L) (Q PDLDEPTH))
07800 MACRO)
07900
08000 (DEFPROP PDLDEPTH
08100 T
08200 SPECIAL)
08300
08400 (DEFPROP Q
08500 (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L)))
08600 MACRO)
08700
08800 (DEFPROP TAGP
08900 (LAMBDA (L) (CONS (Q ATOM) (CDR L)))
09000 MACRO)
09100
09200 (DEFPROP USERWARN
09300 (LAMBDA(L)
09400 (LIST (Q PRINTMSG)
09500 (LIST (Q APPEND)
09600 (LIST (Q LIST) (CADR L))
09700 (LIST (Q Q) (APPEND (CDDR L) (Q (IN))))
09800 (Q (LIST (CURFUN))))))
09900 MACRO)
10000
10100 (DEFPROP FIRSTPROP
10200 (LAMBDA (L) (CONS (Q CDR) (CDR L)))
10300 MACRO)
10400
10500 (DEFPROP LASTPROP
10600 (LAMBDA (L) (CONS (Q NULL) (CDR L)))
10700 MACRO)
10800
10900 (DEFPROP NEXTPROP
11000 (LAMBDA (L) (CONS (Q CDDR) (CDR L)))
11100 MACRO)
11200
11300 (DEFPROP PROPNAM
11400 (LAMBDA (L) (CONS (Q CAR) (CDR L)))
11500 MACRO)
11600
11700 (DEFPROP PROPVAL
11800 (LAMBDA (L) (CONS (Q CADR) (CDR L)))
11900 MACRO)
12000
12100 (DEFPROP PASS1
12200 (LAMBDA(NAME EXPR FLAG)
12300 (PROG (LL CURBIND P1SCNT INPROG FOUNDFREE LOCVS)
12400 (MACLAMBDA (CDR EXPR))
12500 (SETQ INPROG NIL)
12600 (SETQ P1CNT 1)
12700 (SETQ LOCVARS (SETQ SPECVARS NIL))
12800 (SETQ LL (P1BIND (CADR EXPR)))
12900 (COND ((GREATERP (LENGTH LL) NACS) (USERERR EXTRAARGS-PASS1)))
13000 (STARTSYM SUBFUN)
13100 (SETQ EXPR (LIST (CAR EXPR) LL (P1 (CADDR EXPR))))
13200 (STOPSYM SUBFUN)
13300 (COND ((NOT (NULL FOUNDFREE)) (USERWARN (REVERSE FOUNDFREE) UNDECLARED FREE VARIABLES)))
13400 (SETQ LOCVS LOCVARS)
13500 (SETQ LOCVARS NIL)
13600 LOOP (COND ((NULL LOCVS) (RETURN EXPR)))
13700 (COND ((NOT (SPECIALP (CAAR LOCVS))) (SETQ LOCVARS (CONS (CAR LOCVS) LOCVARS))
13800 (SETPROP (CAAR LOCVS) (Q LOCAL) T))
13900 (T (SETQ SPECVARS (ADDTOLIST (CAAR LOCVS) SPECVARS))))
14000 (SETQ LOCVS (CDR LOCVS))
14100 (GO LOOP)))
14200 EXPR)
14300
14400 (DEFPROP MACLAMBDA
14500 (LAMBDA(ZZ)
14600 (COND ((EQ (LENGTH (CDR ZZ)) 1) ZZ)
14700 (T (RPLACA (LAST ZZ) (LIST (QUOTE RETURN) (CAR (LAST ZZ))))
14800 (RPLACD ZZ (LIST (CONS (QUOTE PROG) (CONS NIL (CDR ZZ)))))
14900 ZZ)))
15000 EXPR)
15100
15200 (DEFPROP P1SETQ
15300 (LAMBDA(XPR)
15400 (PROG (VAR TEM VAL)
15500 (COND ((NOT (VARIABLEP (CAR XPR))) (USERERR NOTVARIABLE-P1SETQ)))
15600 (SETQ VAR (COND ((SETQ TEM (ASSOC (CADR XPR) CURBIND)) (CDR TEM)) (T (CADR XPR))))
15700 (VARB VAR)
15800 (SETQ VAL (P1 (CADDR XPR)))
15900 (INCR P1CNT)
16000 (INCR P1CNT)
16100 (RETURN (LIST (Q SETQ) VAR VAL))))
16200 EXPR)
16300
16400 (DEFPROP MACSETQ
16500 (LAMBDA(X)
16600 (PROG (Z Z1)
16700 (SETQ Z (CDAR X))
16800 A (SETQ Z1 (CONS (LIST (QUOTE SETQ) (CAR Z) (CADR Z)) Z1))
16900 (SETQ Z (CDDR Z))
17000 (COND (Z (GO A)))
17100 (SETQ Z1 (REVERSE Z1))
17200 (RPLACA X (CAR Z1))
17300 (RPLACD (LAST Z1) (CDR X))
17400 (RPLACD X (CDR Z1))
17500 (RETURN X)))
17600 EXPR)
17700
17800 (DEFPROP P1PROG
17900 (LAMBDA(X)
18000 ((LAMBDA(CURBIND)
18100 (PROG (TAGLIST P1SCNT PR TEM P1LL INPROG)
18200 (COND ((NULL (CDR X)) (USERERR PROGTOOSHORT-P1PROG)))
18300 (SETQ INPROG T)
18400 (SETQ X (CDR X))
18500 (SETQ P1LL (P1BIND (CAR X)))
18600 (SETQ TEM LOCVARS)
18700 (SETQ P1SCNT (INCR P1CNT))
18800 LOOP1
18900 (SETQ X (CDR X))
19000 (COND ((NULL X) (GO END1)))
19100 (INCR P1CNT)
19200 LOOP2
19300 (COND ((ATOM (CAR X)) (COND ((ASSOC (CAR X) TAGLIST) (USERWARN (CAR X) MULTIPLY DEFINED TAG)))
19400 (SETQ TAGLIST (CONS (CONS (CAR X) (NEXTSYM TAG)) TAGLIST))
19500 (SETQ PR (CONS (CAR X) PR)))
19600 ((AND (EQ (CAAR X) (QUOTE SETQ)) (NOT (EQ (LENGTH (CAR X)) 3))) (MACSETQ X) (GO LOOP2))
19700 (T (SETQ PR (CONS (P1 (CAR X)) PR))))
19800 (GO LOOP1)
19900 END1 (INCR P1CNT)
20000 (P1BUG P1SCNT P1CNT TEM)
20100 (SETQ TEM (GETPROP (Q LOCVARS) (Q VALUE)))
20200 LOOP (COND ((NULL (CDR TEM)) (GO END)))
20300 (COND
20400 ((AND (MEMBER (CAADR TEM) P1LL) (ZEROP (CDADR TEM))) (USERWARN (CAADR TEM) UNUSED PROG VARIABLE)
20500 (SETQ SPECVARS
20600 (ADDTOLIST (CAADR TEM) SPECVARS))
20700 (MAKESPECIAL (CAADR TEM))))
20800 ELOOP
20900 (SETQ TEM (CDR TEM))
21000 (GO LOOP)
21100 END (INCR P1CNT)
21200 (RETURN (MCONS (Q PROG) TAGLIST P1LL (REVERSE PR)))))
21300 CURBIND))
21400 EXPR)
21500
21600 (DEFPROP P2ARG
21700 (LAMBDA(XPR VALAC TEST)
21800 (PROG (ARG)
21900 (SETQ ARG (COMPEXPR (CADR XPR) VALAC))
22000 (COND
22100 ((EQ (CDR ARG) (Q QT)) (CPUSH VALAC)
22200 (OUTMOVE VALAC (MINUS (ADD1 (PDLDEPTH))))
22300 (OUTINST (LIST (Q HRRZ) VALAC (CAR ARG) VALAC))
22400 (REMOVE ARG)
22500 (RETURN (MARKVAL (NOT (NULL VALAC)) VALAC))))
22600 (LOADARG VALAC ARG)
22700 (OUT1 (Q ADD) VALAC (MINUS (ADD1 (PDLDEPTH))))
22800 (OUTINST (LIST (Q HRRZ) VALAC (MINUS INUM0) VALAC))
22900 (RETURN (MARKVAL (NOT (NULL VALAC)) VALAC))))
23000 EXPR)
23100
23200 (DEFPROP P1LAM
23300 (LAMBDA(XPR CURBIND)
23400 (PROG (ARGS VARS BODY)
23500 (SETQ ARGS (P1SUBRARGS (CDR XPR)))
23600 (INCR P1CNT)
23700 (SETQ VARS (P1BIND (CADAR XPR)))
23800 (COND ((NOT (EQUAL (LENGTH ARGS) (LENGTH VARS))) (USERERR ARGNOERR-P1LAM)))
23900 (MACLAMBDA (CDAR XPR))
24000 (SETQ BODY (P1 (CADDAR XPR)))
24100 (INCR P1CNT)
24200 (RETURN (CONS (LIST (Q LAMBDA) VARS BODY) ARGS))))
24300 EXPR)